home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / JARexx / rexxclude.f < prev    next >
Encoding:
FORTH Source  |  1991-12-31  |  4.5 KB  |  174 lines
  1. \ This file compiles Specific TEXTRA interface words to allow
  2. \ compiling the current Textra window.  Compile errors
  3. \ are highlighted in the window.
  4.  
  5. \ 00000 06-aug-91 mdh     Initial version
  6. \ 00001 18-aug-91 mdh     Removed unnecessary code due to phil's underkey. 
  7. \                         Section 4. described above no longer applies.
  8. \                         Incorporated AREXXMOD module
  9. \ 00002 23-sep-91 plb     changed JAR: to JRX:
  10. \ 00003 05-dec-91 plb     Changed to new system using ARexxTools
  11. \                         Added some comments and PUT.TEXTRA
  12. \                         Added DROPs to {REXXCLQUIT}
  13. \ 00004 12-dec-91 plb     Added JForthToFront
  14.  
  15. \ =============== get all the system support stuff...
  16.  
  17. getmodule includes
  18. getmodule arexxmod  \ 00001
  19.  
  20. include? CreatePort()       ju:exec_support
  21. include? tolower            ju:char-macros
  22. include? JForthToFront      ju:find_window
  23. include? task-ARexxTools.f  JRX:ARexxTools.f   \ 00003
  24. include? task-RXUnderKey.f  JRX:RXUnderKey.f
  25.  
  26. ANEW TASK-REXXCLUDE.F
  27.  
  28. decimal
  29.  
  30. 0 .if  \ debugging tools
  31. : TRY  ( -- , send "this" 10 times )
  32.     10 0
  33.     DO
  34.         0" @textn this"  rx.put.textra .
  35.     LOOP
  36. ;
  37.  
  38. : >TEXTRA  ( <command_line> -- , "string" )
  39.     eol word count >dos  dos0 rx.put.textra .
  40. ;
  41. .then
  42.  
  43. : 10N>TEXT  ( n -- adr cnt , in decimal )
  44.   base @ >r  decimal  n>text  r> base !
  45. ;
  46.  
  47. variable RLINE   \ line number being compiled
  48. variable RX_WASRXCLQUIT
  49.  
  50. : TEMPQUIT ( -- , quit without telling textra )
  51.     xblk off   quit
  52. ;
  53.  
  54. \ Make strings that contain difficult characters " and EOL
  55. \ by replacing the 'x'
  56. : "quote"  " x"  ;  ascii " "quote" 1+ c!
  57. : "eol"    " x"  ;  eol "eol" 1+ c!
  58.  
  59. : "append  ( $strfrom $strto -- )  swap count rot $append ;
  60.  
  61. : {REXXCLQUIT} ( -- , tell Textra to show error then QUIT )
  62. \ >newline ." quitting (REXXCLUDE)..."  clinestart @ . clinenum @ .
  63.     xblk off  #tib off  >in off
  64. \
  65. \ tell Textra to highlight offending line
  66.     " @selectline " here $move
  67.     RLINE @ 1- 0 max 10n>text here $append
  68.     here +null   here 1+ rx.put.textra
  69.     drop \ 00003
  70. \
  71. \ tell Textra to notify user of error
  72.     " @notify " here $move  "quote" here "append
  73.     " JForth says 'Problem with line " here "append
  74.     RLINE @ 10n>text here $append
  75.     " '." here "append  "quote" here "append
  76.     here +null   here 1+ rx.put.textra
  77.     drop \ 00003
  78. \
  79. \ now do real old quit
  80.     RX_WASRXCLQUIT dup @ swap off  dup is quit  execute
  81. ;
  82.  
  83. : InitRexxCLQuit   ( -- , vector QUIT )
  84.   RX_WASRXCLQUIT @ 0=
  85.   IF
  86.      what's quit RX_WASRXCLQUIT !   ' {REXXCLQUIT} is quit
  87.   THEN
  88. ;
  89.  
  90. : RestoreRexxCLQuit  ( -- , unvector )
  91.   RX_WASRXCLQUIT @ ?dup
  92.   IF
  93.      is quit   RX_WASRXCLQUIT off
  94.   THEN
  95. ;
  96.  
  97.  
  98. : RDREXXCLUDE  ( -- , include next line from Textra )
  99.   tib  1024
  100.   over clinestart !  cprevstart off
  101. \
  102. \ get next line
  103.   here off  " @get line " count here $append
  104.   RLINE @ 10n>text here $append    1 rline +!
  105.   here count >dos  dos0
  106. \ >newline ." sending: " dos0 0count dump
  107.   rx.put.textra 0=
  108.   IF
  109.      rx-result1 @ 0=
  110.      IF
  111.         "eol" here "append
  112.         ( tib maxlen )  here count  rot over <
  113.         IF
  114.            >newline ." Line from AREXX too long"   quit
  115.         THEN
  116.         ( tib text cnt )  >r  swap r@ move  r> #TIB !  >in off
  117.         \ 1 clinenum +!
  118. \ >newline ." read in: " tib #tib @ type cr \ dump
  119.      ELSE
  120. \ compile ;;; for FILE?
  121.         2drop XBLK off
  122.         even-up  redef? dup @  >r off   $ 033b3b3b here !
  123.         skip-word? on  [compile] :   [compile] ;
  124.         r> redef? !
  125.         pulltib  >newline ." -- TEXTRA compilation finished" cr
  126.         RestoreRexxCLQuit
  127.         JForthToFront \ 00004
  128.      THEN
  129.   ELSE
  130.      2drop  >newline ." PutRexxMsg failed"   tempquit
  131.   THEN
  132. ;
  133.  
  134. : XBLKON  xblk on  interpret ;
  135.  
  136. : REXXCLUDE ( $filename-for-header -- )
  137.   BLK @
  138.   IF
  139.      >newline ." Can't REXXCLUDE if LOADing from screens"  quit
  140.   THEN
  141.   XBLK @
  142.   IF
  143.      >newline ." REXXCLUDE already active"  quit
  144.   THEN
  145.   count >dos  >newline ." -- From TEXTRA: "  dosstring 1+ $type  cr
  146.   FILEHEADERS @
  147.   IF
  148. \
  149. \ this IF section is identical with INCLUDE, should make a subroutine
  150. \ in the kernal.
  151. \
  152.      redef? dup @ >r off
  153.      dosstring 1+ dup c@ dup >r 1+ here cell+ swap move  ( -- )
  154.      here r> 4 + over c!  ( -- here )
  155.      $ 3a3a3a3a swap 1+ odd!
  156.      here count UPPER
  157.      skip-word? on
  158.      [compile] :    [compile] ;
  159.      r> redef? !
  160.      latest
  161.   ELSE
  162.      0
  163.   THEN
  164.   ( -- nfa? )
  165.   ( here -- add later for error checking )
  166.   pushtib clinefile ( -- nfa? clinefile ) !  \ ( -- here &clinefile )
  167. \
  168.   CLINENUM off     tib CLINESTART !     CPREVSTART off
  169.   ( FSP @  sp@ FSP ! -- add later for error checking )
  170.   ' RDREXXCLUDE is XFillTIB  ' XBLKON is RX.AFTER.INTERPRET
  171.   RLINE off   #TIB @  >IN !
  172.   InitRexxCLQuit
  173. ;
  174.